home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / cl-support / wcl-patches.lisp < prev   
Encoding:
Text File  |  1994-09-27  |  2.1 KB  |  69 lines  |  [TEXT/CCL2]
  1. (in-package "LISP")
  2.  
  3.  
  4. ;;; The default version of this function has a bug with relative
  5. ;;; pathnames.
  6.  
  7. (defun pathname->string (p)
  8.   (let ((dirlist (pathname-directory p)))
  9.     (format nil "~A~{~A/~}~A~A~A"
  10.             (case (car dirlist)
  11.               (:absolute "/")
  12.               (:relative "./")
  13.               (:up "../")
  14.               (t ""))
  15.             (cdr dirlist)
  16.             (nil->empty-string (pathname-name p))
  17.             (if (null (pathname-type p)) "" ".")
  18.             (nil->empty-string (pathname-type p)))))
  19.  
  20.  
  21. ;;; The default version of this function defaults the C file to the
  22. ;;; wrong directory -- LOAD can't find it.
  23.  
  24. (defun my-comf (file &key
  25.                   (output-file (merge-pathnames ".o" file))
  26.                   (c-file (merge-pathnames ".c" output-file))
  27.                   (verbose *compile-verbose*)
  28.                   (print *compile-print*)
  29.                   (config *config*)
  30.                   (pic? *pic?*)
  31.                   only-to-c?)
  32.   (old-comf file
  33.         :output-file output-file
  34.         :c-file c-file
  35.         :verbose verbose
  36.         :print print
  37.         :config config
  38.         :pic? pic?
  39.         :only-to-c? only-to-c?))
  40.  
  41. (when (not (fboundp 'old-comf))
  42.   (setf (symbol-function 'old-comf) #'comf)
  43.   (setf (symbol-function 'comf) #'my-comf))
  44.  
  45.  
  46. ;;; WCL's evaluator tries to macroexpand everything before executing
  47. ;;; anything.  Unfortunately, this does the wrong thing with
  48. ;;; top-level PROGN's -- it tries to expand macros in subforms before
  49. ;;; executing earlier subforms that set up stuff required to do the
  50. ;;; the expansion properly.
  51.  
  52. (defun eval-1 (form venv fenv tenv benv)
  53.   (let ((new-form  (macroexpand form *eval-macro-env*)))
  54.     (if (and (consp new-form)
  55.          (eq (car new-form) 'progn))
  56.     (do ((forms (cdr new-form) (cdr forms)))
  57.         ((null (cdr forms)) (eval-1 (car forms) venv fenv tenv benv))
  58.         (eval-1 (car forms) venv fenv tenv benv))
  59.     (let ((expansion (expand new-form)))
  60.       (when (and (listp expansion)
  61.              (eq (car expansion) 'define-function))
  62.         (setf (get (second (second expansion))
  63.                :function-definition)
  64.           form))
  65.       (eval/5 expansion venv fenv tenv benv))
  66.       )))
  67.  
  68.  
  69.